CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/win/vbsmpls.zip/SAMPLES/OLEDB/OLEDB.FRM

Text File | 1994-03-24 | 12KB | 390 lines

VERSION 2.00
Begin Form frmObjVwr
   BackColor       =   &H00C0C0C0&
   Caption         =   "OLEDB"
   ClientHeight    =   5415
   ClientLeft      =   900
   ClientTop       =   2340
   ClientWidth     =   7710
   Height          =   5820
   Icon            =   OLEDB.FRX:0000
   Left            =   840
   LinkTopic       =   "Form1"
   ScaleHeight     =   5415
   ScaleWidth      =   7710
   Top             =   1995
   Width           =   7830
   Begin CommandButton cmdDelete
      Caption         =   "&Delete Current Object"
      Height          =   612
      Left            =   3840
      TabIndex        =   4
      Top             =   4680
      Width           =   2052
   End
   Begin CommandButton cmdNext
      Caption         =   "&Next >>"
      Height          =   492
      Left            =   3840
      TabIndex        =   2
      Top             =   3960
      Width           =   2052
   End
   Begin CommandButton cmdPrevious
      Caption         =   "<< &Previous"
      Height          =   492
      Left            =   1680
      TabIndex        =   1
      Top             =   3960
      Width           =   2052
   End
   Begin OLE oleDisplay
      fFFHk           =   -1  'True
      Height          =   3492
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   7332
   End
   Begin CommandButton cmdAddNew
      Caption         =   "&Add New OLE Object"
      Height          =   612
      Left            =   1680
      TabIndex        =   3
      Top             =   4680
      Width           =   2052
   End
   Begin Label lblFormatInfo
      BackStyle       =   0  'Transparent
      Height          =   252
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   5532
   End
End
'******************************************************************'
'*                                                                *'
'*  OLEDB - Database Storage and Retrieval of OLE Objects         *'
'*                                                                *'
'*  OLEDB.FRM - Front end to display objects and allow the        *'
'*              user to modify the database.                      *'
'*                                                                *'
'*  OLEDB.BAS - Routines that store and retrieve objects.         *'
'*            - Reusable code that can store OLE2 objects         *'
'*              into binary or memo field, retrieve OLE2          *'
'*              objects, and retrieve Access 1.x format OLE       *'
'*              objects.                                          *'
'*            - If an OLE object is added from within Access      *'
'*              the Format field should be set to 1.              *'
'*            - There is not a routine to store Access 1.x        *'
'*              format OLE objects.                               *'
'*                                                                *'
'*  OLEDB.MDB - Access database to hold objects                   *'
'*            - Structure:                                        *'
'*               TABLES: OLEObjects                               *'
'*               FIELDS: OLE_ID     Counter                       *'
'*                       OLEObject  Binary                        *'
'*                       Format     Long                          *'
'*              INDEXES: Index OLE_ID Unique Primary              *'
'*                                                                *'
'******************************************************************'

Option Explicit

Dim dbOLEDB As Database
Dim tbOLEObjects As Dynaset
Dim nRecordCount As Integer
Dim nRecordNumber As Integer
Dim bBusy As Integer            'Used to prevent re-entry
Dim bUpdated As Integer         'Flags that the object has been updated

Const OLE2OBJECT = 0            'Program defined constants for
Const ACCESSOLE1OBJECT = 1      'Format field

Const OLE_DELETE = 10           'OLE2 control actions
Const OLE_INSERT_OBJ_DLG = 14

Const OLE_CHANGED = 0             'OLE updated event codes
Const OLE_SAVED = 1

Const MB_YESNO = 4              'Message Box constants
Const IDYES = 6

'Adds a new Object to the database
'
Sub cmdAddNew_Click ()
If Not bBusy Then
   bBusy = True
   Screen.MousePointer = 11
   DoEvents
   Dim eError As Integer
   If bUpdated Then
      Call PutOLEObject
      DoEvents
      bUpdated = False
   End If
   oleDisplay.Action = OLE_DELETE
   oleDisplay.OLETypeAllowed = 1           'Limit to Embedded objects
   On Error GoTo INSERTERROR:
   oleDisplay.Action = OLE_INSERT_OBJ_DLG
   On Error GoTo 0
   DoEvents
   If oleDisplay.OLEType = 3 Then
      If nRecordNumber <> 0 Then
         Call GetOLEObject
      End If
   Else
      tbOLEObjects.AddNew
      tbOLEObjects("Format") = OLE2OBJECT
      eError = OLEToField(oleDisplay, tbOLEObjects("oleobject"))
      nRecordCount = nRecordCount + 1
      nRecordNumber = nRecordCount
      lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": Stored as OLE2 Object"
      tbOLEObjects.Update
      tbOLEObjects.Bookmark = tbOLEObjects.LastModified
      Call UpdateButtons
      DoEvents
   End If
GoTo EXITADDNEW:
INSERTERROR:
   MsgBox ("The object could not be created.  Try to free up more memory.")
   If nRecordNumber <> 0 Then
      Call GetOLEObject
   End If
   Resume EXITADDNEW:
EXITADDNEW:
   Screen.MousePointer = 0
   bBusy = False
End If
End Sub

'Deletes the current object from the database
'
Sub cmdDelete_Click ()
   If Not bBusy Then
      bBusy = True
      Screen.MousePointer = 11
      DoEvents
      If nRecordNumber <> 0 Then
         oleDisplay.Action = OLE_DELETE
         tbOLEObjects.Delete
         If nRecordNumber <> nRecordCount Then
            tbOLEObjects.MoveNext
            nRecordCount = nRecordCount - 1
            Call GetOLEObject
            Call UpdateButtons
            DoEvents
         Else
            If nRecordNumber = 1 Then
               nRecordCount = 0
               nRecordNumber = 0
               Call UpdateButtons
               lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": No Current Record"
            Else
               tbOLEObjects.MoveLast
               nRecordCount = nRecordCount - 1
               nRecordNumber = nRecordCount
               Call GetOLEObject
               Call UpdateButtons
               DoEvents
            End If
         End If
      End If
      bUpdated = False
      Screen.MousePointer = 0
      bBusy = False
   End If
End Sub

'Moves to the next object in the database
'
Sub cmdNext_Click ()
   If Not bBusy Then
      bBusy = True
      Screen.MousePointer = 11
      DoEvents
      If bUpdated Then
         Call PutOLEObject
         DoEvents
         bUpdated = False
      End If
      If nRecordNumber <> nRecordCount Then
         tbOLEObjects.MoveNext
         nRecordNumber = nRecordNumber + 1
         Call GetOLEObject
         Call UpdateButtons
         DoEvents
      End If
      Screen.MousePointer = 0
      bBusy = False
   End If
End Sub

'Moves to the previous object in the database
'
Sub cmdPrevious_Click ()
   If Not bBusy Then
      bBusy = True
      Screen.MousePointer = 11
      DoEvents
      If bUpdated Then
         Call PutOLEObject
         DoEvents
         bUpdated = False
      End If
      If nRecordNumber > 1 Then
         tbOLEObjects.MovePrevious
         nRecordNumber = nRecordNumber - 1
         Call GetOLEObject
         Call UpdateButtons
         DoEvents
      End If
      Screen.MousePointer = 0
      bBusy = False
   End If
End Sub

'Open up the database and move to the first object
'
'NOTE: No error trapping on the opening the database or table
'
Sub Form_Load ()

   Dim dyOLEObjects As Dynaset

   frmObjVwr.Top = (Screen.Height - frmObjVwr.Height) / 2
   frmObjVwr.Left = (Screen.Width - frmObjVwr.Width) / 2
   Set dbOLEDB = OpenDatabase(App.Path & "\OLEDB.MDB")
   Set tbOLEObjects = dbOLEDB.CreateDynaset("OLEObjects")

   On Error GoTo NOCURRECLOAD:
   tbOLEObjects.MoveLast
   tbOLEObjects.MoveFirst
   On Error GoTo 0
   nRecordCount = tbOLEObjects.RecordCount
   nRecordNumber = 1
   Call GetOLEObject
   Call UpdateButtons
Exit Sub
NOCURRECLOAD:
   nRecordCount = 0
   nRecordNumber = 0
   Call UpdateButtons
   lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": No Current Record"
   Resume EXITSUBLOAD:
EXITSUBLOAD:
End Sub

Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
   If bUpdated Then
      Call PutOLEObject
      DoEvents
      bUpdated = False
   End If
End Sub

'Sizes controls to fit form
'
Sub Form_Resize ()
If frmObjVwr.WindowState <> 1 Then
   If frmObjVwr.ScaleWidth > 4300 Then
      oleDisplay.Width = frmObjVwr.ScaleWidth - 240
      cmdPrevious.Left = frmObjVwr.ScaleWidth \ 2 - 2118
      cmdNext.Left = frmObjVwr.ScaleWidth \ 2 + 66
      cmdAddNew.Left = frmObjVwr.ScaleWidth \ 2 - 2118
      cmdDelete.Left = frmObjVwr.ScaleWidth \ 2 + 66

   End If
   If frmObjVwr.Height > 3000 Then
      oleDisplay.Height = frmObjVwr.ScaleHeight - 2064
      cmdPrevious.Top = frmObjVwr.ScaleHeight - 1488
      cmdNext.Top = frmObjVwr.ScaleHeight - 1488
      cmdAddNew.Top = frmObjVwr.ScaleHeight - 804
      cmdDelete.Top = frmObjVwr.ScaleHeight - 804
   End If
End If
End Sub

'Determines the format of the Object and calls the appropriate
'function to retrieve it
'
'NOTE: eError will never recieve an error unless an error trapping
'scheme is implemented in OLEDB.BAS
'
Sub GetOLEObject ()
   Dim eError As Integer
   If tbOLEObjects("format") = OLE2OBJECT Then
      eError = FieldToOLE(oleDisplay, tbOLEObjects("oleobject"))
      lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": Stored as OLE2 Object"
   Else 'ACCESSOLE1OBJECT
      eError = AccessFieldToOLE(oleDisplay, tbOLEObjects("oleobject"))
      lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": Stored as Access 1.x OLE Object"
   End If
End Sub

'Sets flag to update the current object in the database if the user edits it
'
Sub oleDisplay_Updated (Code As Integer)
   If Not bBusy Then
      bBusy = True
      If Code = OLE_SAVED Then
         Screen.MousePointer = 11
         PutOLEObject
         bUpdated = False
         Screen.MousePointer = 0
      ElseIf Code = OLE_CHANGED Then
         bUpdated = True
      End If
      bBusy = False
   End If
End Sub

Sub PutOLEObject ()
   Dim eError As Integer
   If tbOLEObjects("format") = OLE2OBJECT Then
      tbOLEObjects.Edit
      eError = OLEToField(oleDisplay, tbOLEObjects("oleobject"))
      tbOLEObjects("format") = OLE2OBJECT
      lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": Stored as OLE2 Object"
      tbOLEObjects.Update
      DoEvents
   Else 'OLE1ACCESSOBJECT
      If MsgBox("This program cannot update Access 1.x OLE Objects.  Do you want to save your changes as an OLE2 Object?", MB_YESNO) = IDYES Then
         tbOLEObjects.Edit
         eError = OLEToField(oleDisplay, tbOLEObjects("oleobject"))
         tbOLEObjects("format") = OLE2OBJECT
         lblFormatInfo.Caption = nRecordNumber & " of " & nRecordCount & ": Stored as OLE2 Object"
         tbOLEObjects.Update
         DoEvents
      Else
         GetOLEObject
      End If
   End If
End Sub

Sub UpdateButtons ()
   If nRecordCount = 0 Then
      cmdNext.Enabled = False
      cmdPrevious.Enabled = False
      cmdDelete.Enabled = False
   ElseIf nRecordCount = 1 Then
      cmdNext.Enabled = False
      cmdPrevious.Enabled = False
      cmdDelete.Enabled = True
   ElseIf nRecordNumber = nRecordCount Then
      cmdNext.Enabled = False
      cmdPrevious.Enabled = True
      cmdDelete.Enabled = True
   ElseIf nRecordNumber = 1 Then
      cmdNext.Enabled = True
      cmdPrevious.Enabled = False
      cmdDelete.Enabled = True
   Else
      cmdNext.Enabled = True
      cmdPrevious.Enabled = True
      cmdDelete.Enabled = True
   End If
End Sub